home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / _standard.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  28.3 KB  |  980 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; IEEE Scheme procedures:
  6.  
  7. (define (not x) (touch-vars (x) (##not x)))
  8.  
  9. (define (boolean? x) (touch-vars (x) (or (##eq? x #t) (##eq? x #f))))
  10.  
  11. (define (eqv? x y) (touch-vars (x y) (##eqv? x y)))
  12.  
  13. (define (eq? x y) (touch-vars (x y) (##eq? x y)))
  14.  
  15. (define (equal? x y) (##equal? x y (if-touches #t #f)))
  16.  
  17. (define (pair? x) (touch-vars (x) (##pair? x)))
  18.  
  19. (define (cons x y) (##cons x y))
  20.  
  21. (define (car x) (touch-vars (x) (check-pair x (car x) (##car x))))
  22.  
  23. (define (cdr x) (touch-vars (x) (check-pair x (cdr x) (##cdr x))))
  24.  
  25. (define (set-car! x y)
  26.   (touch-vars (x) (check-pair x (set-car! x y) (##set-car! x y))))
  27.  
  28. (define (set-cdr! x y)
  29.   (touch-vars (x) (check-pair x (set-cdr! x y) (##set-cdr! x y))))
  30.  
  31. (##define-macro (define-c...r name pattern)
  32.  
  33.   (define (gen name pattern)
  34.     `(CHECK-PAIR Y (,name X)
  35.        ,(if (<= pattern 3)
  36.           (if (= pattern 3) '(##CDR Y) '(##CAR Y))
  37.           `(LET ((Y ,(if (odd? pattern) '(##CDR Y) '(##CAR Y))))
  38.              (TOUCH-VARS (Y)
  39.                ,(gen name (quotient pattern 2)))))))
  40.  
  41.   `(DEFINE (,name X)
  42.      (TOUCH-VARS (X)
  43.        (LET ((Y X))
  44.          ,(gen name pattern)))))
  45.  
  46. (define-c...r caar 4)
  47. (define-c...r cadr 5)
  48. (define-c...r cdar 6)
  49. (define-c...r cddr 7)
  50. (define-c...r caaar 8)
  51. (define-c...r caadr 9)
  52. (define-c...r cadar 10)
  53. (define-c...r caddr 11)
  54. (define-c...r cdaar 12)
  55. (define-c...r cdadr 13)
  56. (define-c...r cddar 14)
  57. (define-c...r cdddr 15)
  58. (define-c...r caaaar 16)
  59. (define-c...r caaadr 17)
  60. (define-c...r caadar 18)
  61. (define-c...r caaddr 19)
  62. (define-c...r cadaar 20)
  63. (define-c...r cadadr 21)
  64. (define-c...r caddar 22)
  65. (define-c...r cadddr 23)
  66. (define-c...r cdaaar 24)
  67. (define-c...r cdaadr 25)
  68. (define-c...r cdadar 26)
  69. (define-c...r cdaddr 27)
  70. (define-c...r cddaar 28)
  71. (define-c...r cddadr 29)
  72. (define-c...r cdddar 30)
  73. (define-c...r cddddr 31)
  74.  
  75. (define (null? x) (touch-vars (x) (##null? x)))
  76.  
  77. (define (list? x)
  78.   (let loop ((l1 x) (l2 x))
  79.     (touch-vars (l1)
  80.       (if (##not (##pair? l1))
  81.         (##null? l1)
  82.         (let ((l1 (##cdr l1)))
  83.           (touch-vars (l1 l2)
  84.             (cond ((##eq? l1 l2)
  85.                    #f)
  86.                   ((##pair? l1)
  87.                    (loop (##cdr l1) (##cdr l2)))
  88.                   (else
  89.                    (##null? l1)))))))))
  90.  
  91. (define (list . l) l)
  92.  
  93. (define (length l)
  94.   (let loop ((l l) (n 0))
  95.     (touch-vars (l)
  96.       (if (##pair? l)
  97.         (loop (##cdr l) (##fixnum.+ n 1))
  98.         n))))
  99.  
  100. (define (append . l)
  101.  
  102.   (define (append1 l)
  103.     (if (##pair? (##cdr l))
  104.       (append2 (##car l) (append1 (##cdr l)))
  105.       (##car l)))
  106.  
  107.   (define (append2 l1 l2)
  108.     (touch-vars (l1)
  109.       (if (##pair? l1)
  110.         (let ((result (##cons (##car l1) '())))
  111.           (##set-cdr!
  112.             (let loop ((end result) (l1 (##cdr l1)))
  113.               (touch-vars (l1)
  114.                 (if (##pair? l1)
  115.                   (let ((tail (##cons (##car l1) '())))
  116.                     (##set-cdr! end tail)
  117.                     (loop tail (##cdr l1)))
  118.                   end)))
  119.             l2)
  120.           result)
  121.         l2)))
  122.  
  123.   (if (##pair? l)
  124.     (append1 l)
  125.     '()))
  126.  
  127. (define (reverse l)
  128.   (let loop ((l l) (x '()))
  129.     (touch-vars (l)
  130.       (if (##pair? l)
  131.         (loop (##cdr l) (##cons (##car l) x))
  132.         x))))
  133.  
  134. (define (list-ref l k)
  135.   (touch-vars (k)
  136.     (check-exact-int-non-neg k (list-ref l k)
  137.       (let loop ((x l) (i k))
  138.         (touch-vars (x)
  139.           (check-pair x (list-ref l k)
  140.             (if (##fixnum.< 0 i)
  141.               (loop (##cdr x) (##fixnum.- i 1))
  142.               (##car x))))))))
  143.  
  144. (define (memq x l)
  145.   (touch-vars (x)
  146.     (let loop ((l l))
  147.       (touch-vars (l)
  148.         (if (##pair? l)
  149.           (let ((y (##car l)))
  150.             (touch-vars (y)
  151.               (if (##eq? x y)
  152.                 l
  153.                 (loop (##cdr l)))))
  154.           #f)))))
  155.  
  156. (define (memv x l)
  157.   (touch-vars (x)
  158.     (let loop ((l l))
  159.       (touch-vars (l)
  160.         (if (##pair? l)
  161.           (let ((y (##car l)))
  162.             (touch-vars (y)
  163.               (if (##eqv? x y)
  164.                 l
  165.                 (loop (##cdr l)))))
  166.           #f)))))
  167.  
  168. (define (member x l)
  169.   (let loop ((l l))
  170.     (touch-vars (l)
  171.       (if (##pair? l)
  172.         (let ((y (##car l)))
  173.           (if (##equal? x y (if-touches #t #f))
  174.             l
  175.             (loop (##cdr l))))
  176.         #f))))
  177.  
  178. (define (assq x l)
  179.   (touch-vars (x l)
  180.     (let loop ((y l))
  181.       (if (##pair? y)
  182.         (let ((couple (##car y)))
  183.           (touch-vars (couple)
  184.             (check-pair couple (assq x l)
  185.               (let ((z (##car couple)))
  186.                 (touch-vars (z)
  187.                   (if (##eq? x z)
  188.                     couple
  189.                     (let ((y (##cdr y)))
  190.                       (touch-vars (y)
  191.                         (loop y)))))))))
  192.         #f))))
  193.  
  194. (define (assv x l)
  195.   (touch-vars (x l)
  196.     (let loop ((y l))
  197.       (if (##pair? y)
  198.         (let ((couple (##car y)))
  199.           (touch-vars (couple)
  200.             (check-pair couple (assv x l)
  201.               (let ((z (##car couple)))
  202.                 (touch-vars (z)
  203.                   (if (##eqv? x z)
  204.                     couple
  205.                     (let ((y (##cdr y)))
  206.                       (touch-vars (y)
  207.                         (loop y)))))))))
  208.         #f))))
  209.  
  210. (define (assoc x l)
  211.   (touch-vars (l)
  212.     (let loop ((y l))
  213.       (if (##pair? y)
  214.         (let ((couple (##car y)))
  215.           (touch-vars (couple)
  216.             (check-pair couple (assoc x l)
  217.               (let ((z (##car couple)))
  218.                 (if (##equal? x z (if-touches #t #f))
  219.                   couple
  220.                   (let ((y (##cdr y)))
  221.                     (touch-vars (y)
  222.                       (loop y))))))))
  223.         #f))))
  224.  
  225. (define (symbol? x) (touch-vars (x) (##symbol? x)))
  226.  
  227. (define (symbol->string sym)
  228.   (touch-vars (sym)
  229.     (check-symbol sym (symbol->string sym)
  230.       (##symbol->string sym))))
  231.  
  232. (define (string->symbol str)
  233.   (touch-vars (str)
  234.     (check-string str (string->symbol str)
  235.       (##string->symbol str))))
  236.  
  237. (define (number? x)   (touch-vars (x) (##complex? x)))
  238. (define (complex? x)  (touch-vars (x) (##complex? x)))
  239. (define (real? x)     (touch-vars (x) (##real? x)))
  240. (define (rational? x) (touch-vars (x) (##rational? x)))
  241. (define (integer? x)  (touch-vars (x) (##integer? x)))
  242.  
  243. (define (exact? x)   (touch-vars (x) (##exact? x)))
  244. (define (inexact? x) (touch-vars (x) (##not (##exact? x))))
  245.  
  246. (define-nary0-boolean (=  x y) (##= x y) no-check touch-vars)
  247. (define-nary0-boolean (<  x y) (##< x y) no-check touch-vars)
  248. (define-nary0-boolean (>  x y) (##< y x) no-check touch-vars)
  249. (define-nary0-boolean (<= x y) (##not (##< y x)) no-check touch-vars)
  250. (define-nary0-boolean (>= x y) (##not (##< x y)) no-check touch-vars)
  251.  
  252. (define (zero? x)     (touch-vars (x) (##zero? x)))
  253. (define (positive? x) (touch-vars (x) (##positive? x)))
  254. (define (negative? x) (touch-vars (x) (##negative? x)))
  255. (define (odd? x)      (touch-vars (x) (##odd? x)))
  256. (define (even? x)     (touch-vars (x) (##not (##odd? x))))
  257.  
  258. (define-nary1 (max x y) x (##max x y) touch-vars)
  259. (define-nary1 (min x y) x (##min x y) touch-vars)
  260.  
  261. (define-nary0 (+ x y) 0 x (##+ x y) touch-vars)
  262. (define-nary0 (* x y) 1 x (##* x y) touch-vars)
  263. (define-nary1 (- x y) (##- 0 x) (##- x y) touch-vars)
  264. (define-nary1 (/ x y) (##/ 1 x) (##/ x y) touch-vars)
  265.  
  266. (define (abs x) (touch-vars (x) (##abs x)))
  267.  
  268. (define (quotient x y)  (touch-vars (x y) (##quotient x y)))
  269. (define (remainder x y) (touch-vars (x y) (##remainder x y)))
  270. (define (modulo x y)    (touch-vars (x y) (##modulo x y)))
  271.  
  272. (define-nary0 (gcd x y) 0 x (##gcd x y) touch-vars)
  273. (define-nary0 (lcm x y) 1 x (##lcm x y) touch-vars)
  274.  
  275. (define (numerator x)   (touch-vars (x) (##numerator x)))
  276. (define (denominator x) (touch-vars (x) (##denominator x)))
  277.  
  278. (define (floor x)    (touch-vars (x) (##floor x)))
  279. (define (ceiling x)  (touch-vars (x) (##ceiling x)))
  280. (define (truncate x) (touch-vars (x) (##truncate x)))
  281. (define (round x)    (touch-vars (x) (##round x)))
  282.  
  283. (define (rationalize x y) (touch-vars (x y) (##rationalize x y)))
  284.  
  285. (define (exp x)  (touch-vars (x) (##exp x)))
  286. (define (log x)  (touch-vars (x) (##log x)))
  287. (define (sin x)  (touch-vars (x) (##sin x)))
  288. (define (cos x)  (touch-vars (x) (##cos x)))
  289. (define (tan x)  (touch-vars (x) (##tan x)))
  290. (define (asin x) (touch-vars (x) (##asin x)))
  291. (define (acos x) (touch-vars (x) (##acos x)))
  292.  
  293. (define (atan x (y))
  294.   (touch-vars (x)
  295.     (if (##unassigned? y)
  296.       (##atan x)
  297.       (touch-vars (y)
  298.         (##atan2 x y)))))
  299.  
  300. (define (sqrt x) (touch-vars (x) (##sqrt x)))
  301.  
  302. (define (expt x y) (touch-vars (x y) (##expt x y)))
  303.  
  304. (define (make-rectangular x y)
  305.   (touch-vars (x y) (##make-rectangular x y)))
  306.  
  307. (define (make-polar x y) (touch-vars (x y) (##make-polar x y)))
  308. (define (real-part x)    (touch-vars (x) (##real-part x)))
  309. (define (imag-part x)    (touch-vars (x) (##imag-part x)))
  310. (define (magnitude x)    (touch-vars (x) (##magnitude x)))
  311. (define (angle x)        (touch-vars (x) (##angle x)))
  312.  
  313. (define (exact->inexact x)
  314.   (touch-vars (x) (##exact->inexact x)))
  315.  
  316. (define (inexact->exact x)
  317.   (touch-vars (x) (##inexact->exact x)))
  318.  
  319. (define (number->string n (r))
  320.   (touch-vars (n)
  321.     (if (##unassigned? r)
  322.       (##number->string n 10)
  323.       (touch-vars (r)
  324.         (##number->string n r)))))
  325.  
  326. (define (string->number s (r))
  327.   (touch-vars (s)
  328.     (if (##unassigned? r)
  329.       (check-string s (string->number s)
  330.         (##string->number s 10))
  331.       (touch-vars (r)
  332.         (check-string s (string->number s r)
  333.           (##string->number s r))))))
  334.  
  335. (define (char? x) (touch-vars (x) (##char? x)))
  336.  
  337. (define-nary0-boolean (char=? x y)
  338.   (##char=? x y) check-char touch-vars)
  339.  
  340. (define-nary0-boolean (char<? x y)
  341.   (##char<? x y) check-char touch-vars)
  342.  
  343. (define-nary0-boolean (char>? x y)
  344.   (##char<? y x) check-char touch-vars)
  345.  
  346. (define-nary0-boolean (char<=? x y)
  347.   (##not (##char<? y x)) check-char touch-vars)
  348.  
  349. (define-nary0-boolean (char>=? x y)
  350.   (##not (##char<? x y)) check-char touch-vars)
  351.  
  352. (define-nary0-boolean (char-ci=? x y)
  353.   (##char-ci=? x y) check-char touch-vars)
  354.  
  355. (define-nary0-boolean (char-ci<? x y)
  356.   (##char-ci<? x y) check-char touch-vars)
  357.  
  358. (define-nary0-boolean (char-ci>? x y)
  359.   (##char-ci<? y x) check-char touch-vars)
  360.  
  361. (define-nary0-boolean (char-ci<=? x y)
  362.   (##not (##char-ci<? y x)) check-char touch-vars)
  363.  
  364. (define-nary0-boolean (char-ci>=? x y)
  365.   (##not (##char-ci<? x y)) check-char touch-vars)
  366.  
  367. (define (char-alphabetic? c)
  368.   (touch-vars (c)
  369.     (check-char c (char-alphabetic? c)
  370.       (##char-alphabetic? c))))
  371.  
  372. (define (char-numeric? c)
  373.   (touch-vars (c)
  374.     (check-char c (char-numeric? c)
  375.       (##char-numeric? c))))
  376.  
  377. (define (char-whitespace? c)
  378.   (touch-vars (c)
  379.     (check-char c (char-whitespace? c)
  380.       (##char-whitespace? c))))
  381.  
  382. (define (char-upper-case? c)
  383.   (touch-vars (c)
  384.     (check-char c (char-upper-case? c)
  385.       (##char-upper-case? c))))
  386.  
  387. (define (char-lower-case? c)
  388.   (touch-vars (c)
  389.     (check-char c (char-lower-case? c)
  390.       (##char-lower-case? c))))
  391.  
  392. (define (char->integer c)
  393.   (touch-vars (c)
  394.     (check-char c (char->integer c)
  395.       (##char->integer c))))
  396.  
  397. (define (integer->char n)
  398.   (touch-vars (n)
  399.     (check-exact-int-range n 0 (char-range) (integer->char n)
  400.       (##integer->char n))))
  401.  
  402. (define (char-upcase c)
  403.   (touch-vars (c)
  404.     (check-char c (char-upcase c)
  405.       (##char-upcase c))))
  406.  
  407. (define (char-downcase c)
  408.   (touch-vars (c)
  409.     (check-char c (char-downcase c)
  410.       (##char-downcase c))))
  411.  
  412. (define (string? x) (touch-vars (x) (##string? x)))
  413.  
  414. (define (make-string x (y))
  415.   (touch-vars (x)
  416.     (if (##unassigned? y)
  417.       (check-exact-int-non-neg x (make-string x)
  418.         (##make-string x #\space))
  419.       (touch-vars (y)
  420.         (check-exact-int-non-neg x (make-string x y)
  421.           (check-char y (make-string x y)
  422.             (##make-string x y)))))))
  423.  
  424. (define (string . l)
  425.   (let* ((n (##length l))
  426.          (str (##make-string n #\space)))
  427.     (let loop ((x l) (i 0))
  428.       (if (##pair? x)
  429.         (let ((c (##car x)))
  430.           (check-char c (string . l)
  431.             (begin
  432.               (##string-set! str i c)
  433.               (loop (##cdr x) (##fixnum.+ i 1)))))
  434.         str))))
  435.  
  436. (define (string-length x)
  437.   (touch-vars (x)
  438.     (check-string x (string-length x)
  439.       (##string-length x))))
  440.  
  441. (define (string-ref x y)
  442.   (touch-vars (x y)
  443.     (check-string x (string-ref x y)
  444.       (check-exact-int-range y 0 (##string-length x) (string-ref x y)
  445.         (##string-ref x y)))))
  446.  
  447. (define (string-set! x y z)
  448.   (touch-vars (x y z)
  449.     (check-string x (string-set! x y z)
  450.       (check-exact-int-range y 0 (##string-length x) (string-set! x y z)
  451.         (check-char z (string-set! x y z)
  452.           (##string-set! x y z))))))
  453.  
  454. (define-nary0-boolean (string=? x y)
  455.   (##string=? x y) check-string touch-vars)
  456.  
  457. (define-nary0-boolean (string<? x y)
  458.   (##string<? x y) check-string touch-vars)
  459.  
  460. (define-nary0-boolean (string>? x y)
  461.   (##string<? y x) check-string touch-vars)
  462.  
  463. (define-nary0-boolean (string<=? x y)
  464.   (##not (##string<? y x)) check-string touch-vars)
  465.  
  466. (define-nary0-boolean (string>=? x y)
  467.   (##not (##string<? x y)) check-string touch-vars)
  468.  
  469. (define-nary0-boolean (string-ci=? x y)
  470.   (##string-ci=? x y) check-string touch-vars)
  471.  
  472. (define-nary0-boolean (string-ci<? x y)
  473.   (##string-ci<? x y) check-string touch-vars)
  474.  
  475. (define-nary0-boolean (string-ci>? x y)
  476.   (##string-ci<? y x) check-string touch-vars)
  477.  
  478. (define-nary0-boolean (string-ci<=? x y)
  479.   (##not (##string-ci<? y x)) check-string touch-vars)
  480.  
  481. (define-nary0-boolean (string-ci>=? x y)
  482.   (##not (##string-ci<? x y)) check-string touch-vars)
  483.  
  484. (define (substring x y z)
  485.   (touch-vars (x y z)
  486.     (check-string x (substring x y z)
  487.       (check-exact-int-range-incl y 0 (##string-length x) (substring x y z)
  488.         (check-exact-int-range-incl z y (##string-length x) (substring x y z)
  489.           (##substring x y z))))))
  490.  
  491. (define (string-append . l)
  492.   (let loop1 ((n 0) (x l) (y '()))
  493.     (if (##pair? x)
  494.       (let ((s (##car x)))
  495.         (touch-vars (s)
  496.           (check-string s (string-append . l)
  497.             (loop1 (##fixnum.+ n (##string-length s)) (##cdr x) (##cons s y)))))
  498.       (let ((result (##make-string n #\space)))
  499.         (let loop2 ((k (##fixnum.- n 1)) (y y))
  500.           (if (##pair? y)
  501.             (let ((s (##car y)))
  502.               (let loop3 ((i k) (j (##fixnum.- (##string-length s) 1)))
  503.                 (if (##not (##fixnum.< j 0))
  504.                   (begin
  505.                     (##string-set! result i (##string-ref s j))
  506.                     (loop3 (##fixnum.- i 1) (##fixnum.- j 1)))
  507.                   (loop2 i (##cdr y)))))
  508.             result))))))
  509.  
  510. (define (vector? x) (touch-vars (x) (##vector? x)))
  511.  
  512. (define (make-vector x (y))
  513.   (touch-vars (x)
  514.     (if (##unassigned? y)
  515.       (check-exact-int-non-neg x (make-vector x)
  516.         (##make-vector x #f))
  517.       (touch-vars (y)
  518.         (check-exact-int-non-neg x (make-vector x y)
  519.           (##make-vector x y))))))
  520.  
  521. (define (vector . l)
  522.   (let* ((n (##length l))
  523.          (vect (##make-vector n #f)))
  524.     (let loop ((x l) (i 0))
  525.       (if (##pair? x)
  526.         (begin
  527.           (##vector-set! vect i (##car x))
  528.           (loop (##cdr x) (##fixnum.+ i 1)))
  529.         vect))))
  530.  
  531. (define (vector-length x)
  532.   (touch-vars (x)
  533.     (check-vector x (vector-length x)
  534.       (##vector-length x))))
  535.  
  536. (define (vector-ref x y)
  537.   (touch-vars (x y)
  538.     (check-vector x (vector-ref x y)
  539.       (check-exact-int-range y 0 (##vector-length x) (vector-ref x y)
  540.         (##vector-ref x y)))))
  541.  
  542. (define (vector-set! x y z)
  543.   (touch-vars (x y)
  544.     (check-vector x (vector-set! x y z)
  545.       (check-exact-int-range y 0 (##vector-length x) (vector-set! x y z)
  546.         (##vector-set! x y z)))))
  547.  
  548. (define (procedure? x) (touch-vars (x) (##procedure? x)))
  549.  
  550. (define (apply p x . l)
  551.  
  552.   (define (arg-list prev rest)
  553.     (if (##pair? rest)
  554.       (##cons prev (arg-list (##car rest) (##cdr rest)))
  555.       (if-touches
  556.         (let loop ((l prev))
  557.           (touch-vars (l)
  558.             (if (##pair? l)
  559.               (##cons (##car l) (loop (##cdr l)))
  560.               '())))
  561.         prev)))
  562.  
  563.   (touch-vars (p)
  564.     (check-procedure p (apply p x . l)
  565.       (##apply p (arg-list x l)))))
  566.  
  567. (define (map p l1 . l2)
  568.   (touch-vars (p)
  569.     (check-procedure p (map p l1 . l2)
  570.       (if (##null? l2)
  571.  
  572.         (touch-vars (l1)
  573.           (if (##pair? l1)
  574.  
  575.             (let ((result (##cons (p (##car l1)) '())))
  576.               (let loop1 ((end result) (x (##cdr l1)))
  577.                 (touch-vars (x)
  578.                   (if (##pair? x)
  579.                     (let ((tail (##cons (p (##car x)) '())))
  580.                       (##set-cdr! end tail)
  581.                       (loop1 tail (##cdr x))))))
  582.               result)
  583.  
  584.             '()))
  585.  
  586.         (let ((reversed-lists (##reverse (##cons l1 l2))))
  587.  
  588.           (define (end-of-lists l result)
  589.             (if (##eq? l reversed-lists)
  590.               (let loop ((l l))
  591.                 (if (##pair? l)
  592.                   (let ((head (##car l)))
  593.                     (touch-vars (head)
  594.                       (if (##pair? head)
  595.                         (trap-list-lengths (map p l1 . l2))
  596.                         (loop (##cdr l)))))
  597.                   result))
  598.               (trap-list-lengths (map p l1 . l2))))
  599.  
  600.           (let loop2 ((l reversed-lists) (args '()))
  601.             (if (##pair? l)
  602.  
  603.               (let ((head (##car l)))
  604.                 (touch-vars (head)
  605.                   (if (##pair? head)
  606.                     (begin
  607.                       (##set-car! l (##cdr head))
  608.                       (loop2 (##cdr l) (##cons (##car head) args)))
  609.                     (if-checks (end-of-lists l '()) '()))))
  610.  
  611.               (let ((result (##cons (##apply p args) '())))
  612.                 (let loop3 ((end result))
  613.                   (let loop4 ((l reversed-lists) (args '()))
  614.                     (if (##pair? l)
  615.  
  616.                       (let ((head (##car l)))
  617.                         (touch-vars (head)
  618.                           (if (##pair? head)
  619.                             (begin
  620.                               (##set-car! l (##cdr head))
  621.                               (loop4 (##cdr l) (##cons (##car head) args)))
  622.                             (if-checks (end-of-lists l result) result))))
  623.  
  624.                       (let ((tail (##cons (##apply p args) '())))
  625.                         (##set-cdr! end tail)
  626.                         (loop3 tail)))))))))))))
  627.  
  628. (define (for-each p l1 . l2)
  629.   (touch-vars (p)
  630.     (check-procedure p (for-each p l1 . l2)
  631.       (if (##null? l2)
  632.  
  633.         (let loop1 ((x l1))
  634.           (touch-vars (x)
  635.             (if (##pair? x)
  636.               (begin
  637.                 (p (##car x))
  638.                 (loop1 (##cdr x))))))
  639.  
  640.         (let ((reversed-lists (##reverse (##cons l1 l2))))
  641.  
  642.           (define (end-of-lists l)
  643.             (if (##eq? l reversed-lists)
  644.               (let loop ((l l))
  645.                 (if (##pair? l)
  646.                   (let ((head (##car l)))
  647.                     (touch-vars (head)
  648.                       (if (##pair? head)
  649.                         (trap-list-lengths (for-each p l1 . l2))
  650.                         (loop (##cdr l)))))
  651.                   ##undef-object))
  652.               (trap-list-lengths (for-each p l1 . l2))))
  653.  
  654.           (let loop2 ()
  655.             (let loop3 ((l reversed-lists) (args '()))
  656.               (if (##pair? l)
  657.  
  658.                 (let ((head (##car l)))
  659.                   (touch-vars (head)
  660.                     (if (##pair? head)
  661.                       (begin
  662.                         (##set-car! l (##cdr head))
  663.                         (loop3 (##cdr l) (##cons (##car head) args)))
  664.                       (if-checks (end-of-lists l) ##undef-object))))
  665.  
  666.                 (begin
  667.                   (##apply p args)
  668.                   (loop2))))))))))
  669.  
  670. (define (call-with-current-continuation p)
  671.   (touch-vars (p)
  672.     (check-procedure p (call-with-current-continuation p)
  673.       (##call-with-current-continuation p))))
  674.  
  675. (define (call-with-input-file s p)
  676.   (touch-vars (s p)
  677.     (check-string s (call-with-input-file s p)
  678.       (check-procedure p (call-with-input-file s p)
  679.         (let ((port (##open-input-file s)))
  680.           (if port
  681.             (let ((result (p port)))
  682.               (##close-port port)
  683.               result)
  684.             (trap-open-file (call-with-input-file s p))))))))
  685.  
  686. (define (call-with-output-file s p)
  687.   (touch-vars (s p)
  688.     (check-string s (call-with-output-file s p)
  689.       (check-procedure p (call-with-output-file s p)
  690.         (let ((port (##open-output-file s)))
  691.           (if port
  692.             (let ((result (p port)))
  693.               (##close-port port)
  694.               result)
  695.             (trap-open-file (call-with-output-file s p))))))))
  696.  
  697. (define (input-port? x)
  698.   (touch-vars (x)
  699.     (##input-port? x)))
  700.  
  701. (define (output-port? x)
  702.   (touch-vars (x)
  703.     (##output-port? x)))
  704.  
  705. (define (current-input-port)
  706.   (##current-input-port))
  707.  
  708. (define (current-output-port)
  709.   (##current-output-port))
  710.  
  711. (define (open-input-file s)
  712.   (touch-vars (s)
  713.     (check-string s (open-input-file s)
  714.       (let ((port (##open-input-file s)))
  715.         (if port
  716.           port
  717.           (trap-open-file (open-input-file s)))))))
  718.  
  719. (define (open-output-file s)
  720.   (touch-vars (s)
  721.     (check-string s (open-output-file s)
  722.       (let ((port (##open-output-file s)))
  723.         (if port
  724.           port
  725.           (trap-open-file (open-output-file s)))))))
  726.  
  727. (define (close-input-port p)
  728.   (touch-vars (p)
  729.     (check-input-port p (close-input-port p)
  730.       (begin
  731.         (##close-port p)
  732.         ##undef-object))))
  733.  
  734. (define (close-output-port p)
  735.   (touch-vars (p)
  736.     (check-output-port p (close-output-port p)
  737.       (begin
  738.         (##close-port p)
  739.         ##undef-object))))
  740.  
  741. (define (eof-object? x)
  742.   (touch-vars (x)
  743.     (##eof-object? x)))
  744.  
  745. (define (read (p))
  746.   (if (##unassigned? p)
  747.     (let ((port (##current-input-port)))
  748.       (check-open-port port (read)
  749.         (##read port)))
  750.     (touch-vars (p)
  751.       (check-input-port p (read p)
  752.         (check-open-port p (read p)
  753.           (##read p))))))
  754.  
  755. (define (read-char (p))
  756.   (if (##unassigned? p)
  757.     (let ((port (##current-input-port)))
  758.       (check-open-port port (read-char)
  759.         (##read-char port)))
  760.     (touch-vars (p)
  761.       (check-input-port p (read-char p)
  762.         (check-open-port p (read-char p)
  763.           (##read-char p))))))
  764.  
  765. (define (peek-char (p))
  766.   (if (##unassigned? p)
  767.     (let ((port (##current-input-port)))
  768.       (check-open-port port (peek-char)
  769.         (##peek-char port)))
  770.     (touch-vars (p)
  771.       (check-input-port p (peek-char p)
  772.         (check-open-port p (peek-char p)
  773.           (##peek-char p))))))
  774.   
  775. (define (write obj (p))
  776.   (if (##unassigned? p)
  777.     (let ((port (##current-output-port)))
  778.       (check-open-port port (write obj)
  779.         (##write obj port (if-touches #t #f))))
  780.     (touch-vars (p)
  781.       (check-output-port p (write obj p)
  782.         (check-open-port p (write obj p)
  783.           (##write obj p (if-touches #t #f)))))))
  784.  
  785. (define (display obj (p))
  786.   (if (##unassigned? p)
  787.     (let ((port (##current-output-port)))
  788.       (check-open-port port (display obj)
  789.         (##display obj port (if-touches #t #f))))
  790.     (touch-vars (p)
  791.       (check-output-port p (display obj p)
  792.         (check-open-port p (display obj p)
  793.           (##display obj p (if-touches #t #f)))))))
  794.  
  795. (define (newline (p))
  796.   (if (##unassigned? p)
  797.     (let ((port (##current-output-port)))
  798.       (check-open-port port (newline)
  799.         (##newline port)))
  800.     (touch-vars (p)
  801.       (check-output-port p (newline p)
  802.         (check-open-port p (newline p)
  803.           (##newline p))))))
  804.  
  805. (define (write-char c (p))
  806.   (touch-vars (c)
  807.     (if (##unassigned? p)
  808.       (check-char c (write-char c)
  809.         (let ((port (##current-output-port)))
  810.           (check-open-port port (write-char c)
  811.             (##write-char c port))))
  812.       (touch-vars (p)
  813.         (check-char c (write-char c p)
  814.           (check-output-port p (write-char c p)
  815.             (check-open-port p (write-char c p)
  816.               (##write-char c p))))))))
  817.  
  818. ;------------------------------------------------------------------------------
  819.  
  820. ; R4RS Scheme procedures:
  821.  
  822. (define (list-tail l k)
  823.   (touch-vars (k)
  824.     (check-exact-int-non-neg k (list-tail l k)
  825.       (let loop ((x l) (i k))
  826.         (if (##fixnum.< 0 i)
  827.           (touch-vars (x)
  828.             (check-pair x (list-tail l k)
  829.               (loop (##cdr x) (##fixnum.- i 1))))
  830.           x)))))
  831.  
  832. (define (string->list str)
  833.   (touch-vars (str)
  834.     (check-string str (string->list str)
  835.       (let loop ((l '()) (i (##fixnum.- (##string-length str) 1)))
  836.         (if (##fixnum.< i 0)
  837.           l
  838.           (loop (##cons (##string-ref str i) l) (##fixnum.- i 1)))))))
  839.  
  840. (define (list->string l)
  841.   (let loop1 ((x l) (n 0))
  842.     (touch-vars (x)
  843.       (if (##pair? x)
  844.         (loop1 (##cdr x) (##fixnum.+ n 1))
  845.         (let ((str (##make-string n #\space)))
  846.           (let loop2 ((x l) (i 0))
  847.             (touch-vars (x)
  848.               (if (##pair? x)
  849.                 (let ((c (##car x)))
  850.                   (check-char c (list->string l)
  851.                     (begin
  852.                       (##string-set! str i c)
  853.                       (loop2 (##cdr x) (##fixnum.+ i 1)))))
  854.                 str))))))))
  855.  
  856. (define (string-copy str)
  857.   (touch-vars (str)
  858.     (check-string str (string-copy str)
  859.       (let* ((n (##string-length str))
  860.              (result (##make-string n #\space)))
  861.         (let loop ((i (##fixnum.- n 1)))
  862.           (if (##fixnum.< i 0)
  863.             result
  864.             (begin
  865.               (##string-set! result i (##string-ref str i))
  866.               (loop (##fixnum.- i 1)))))))))
  867.  
  868. (define (string-fill! str c)
  869.   (touch-vars (str c)
  870.     (check-string str (string-fill str c)
  871.       (check-char c (string-fill str c)
  872.         (let ((n (##string-length str)))
  873.           (let loop ((i (##fixnum.- n 1)))
  874.             (if (##fixnum.< i 0)
  875.               ##undef-object
  876.               (begin
  877.                 (##string-set! str i c)
  878.                 (loop (##fixnum.- i 1))))))))))
  879.  
  880. (define (vector->list vect)
  881.   (touch-vars (vect)
  882.     (check-vector vect (vector->list vect)
  883.       (let loop ((l '()) (i (##fixnum.- (##vector-length vect) 1)))
  884.         (if (##fixnum.< i 0)
  885.           l
  886.           (loop (##cons (##vector-ref vect i) l) (##fixnum.- i 1)))))))
  887.  
  888. (define (list->vector l)
  889.   (let loop1 ((x l) (n 0))
  890.     (touch-vars (x)
  891.       (if (##pair? x)
  892.         (loop1 (##cdr x) (##fixnum.+ n 1))
  893.         (let ((vect (##make-vector n #f)))
  894.           (let loop2 ((x l) (i 0))
  895.             (touch-vars (x)
  896.               (if (##pair? x)
  897.                 (begin
  898.                   (##vector-set! vect i (##car x))
  899.                   (loop2 (##cdr x) (##fixnum.+ i 1)))
  900.                 vect))))))))
  901.  
  902. (define (vector-fill! vect x)
  903.   (touch-vars (vect x)
  904.     (check-vector vect (vector-fill vect x)
  905.       (let ((n (##vector-length vect)))
  906.         (let loop ((i (##fixnum.- n 1)))
  907.           (if (##fixnum.< i 0)
  908.             ##undef-object
  909.             (begin
  910.               (##vector-set! vect i x)
  911.               (loop (##fixnum.- i 1)))))))))
  912.  
  913. (define (force x)
  914.   (##touch x))
  915.  
  916. (define (with-input-from-file s thunk)
  917.   (touch-vars (s thunk)
  918.     (check-string s (with-input-from-file s thunk)
  919.       (check-procedure thunk (with-input-from-file s thunk)
  920.         (let ((port (##open-input-file s)))
  921.           (if port
  922.             (let ((result (##dynamic-bind (##list (##cons '##CURRENT-INPUT-PORT port)) thunk)))
  923.               (##close-port port)
  924.               result)
  925.             (trap-open-file (with-input-from-file s thunk))))))))
  926.  
  927. (define (with-output-to-file s thunk)
  928.   (touch-vars (s thunk)
  929.     (check-string s (with-output-to-file s thunk)
  930.       (check-procedure thunk (with-output-to-file s thunk)
  931.         (let ((port (##open-output-file s)))
  932.           (if port
  933.             (let ((result (##dynamic-bind (##list (##cons '##CURRENT-OUTPUT-PORT port)) thunk)))
  934.               (##close-port port)
  935.               result)
  936.             (trap-open-file (with-output-to-file s thunk))))))))
  937.  
  938. (define (char-ready? (p))
  939.   (if (##unassigned? p)
  940.     (let ((port (##current-input-port)))
  941.       (check-open-port port (char-ready?)
  942.         (##char-ready? port)))
  943.     (touch-vars (p)
  944.       (check-input-port p (char-ready? p)
  945.         (check-open-port p (char-ready? p)
  946.           (##char-ready? p))))))
  947.  
  948. (define (load s (trace?))
  949.   (touch-vars (s)
  950.     (check-string s (load s)
  951.       (if (or (##unassigned? trace?) (##not trace?))
  952.         (##load s #f)
  953.         (##load s ##stdout)))))
  954.  
  955. (define (transcript-on s)
  956.   (touch-vars (s)
  957.     (check-string s (transcript-on s)
  958.       (let ((port (##open-output-file s)))
  959.         (if port
  960.           (begin
  961.             (##transcript-on port)
  962.             s)
  963.           (trap-open-file (transcript-on s)))))))
  964.  
  965. (define (transcript-off)
  966.   (if ##transcript-port
  967.     (begin
  968.       (##close-port ##transcript-port)
  969.       ##undef-object)
  970.     (trap-no-transcript (transcript-off))))
  971.  
  972. ;------------------------------------------------------------------------------
  973.  
  974. ; Multilisp procedures:
  975.  
  976. (define (touch x)
  977.   (##touch x))
  978.  
  979. ;------------------------------------------------------------------------------
  980.